home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Visual Basic 4 Database How-To
/
Visual Basic 4 Database - How-to (The Waite Group)(1995).iso
/
usrgrp32.fr_
/
usrgrp32.fr
Wrap
Text File
|
1995-09-04
|
6KB
|
216 lines
VERSION 4.00
Begin VB.Form frmMain
BackColor = &H00C0C0C0&
Caption = "Add User to Group"
ClientHeight = 2100
ClientLeft = 1890
ClientTop = 2055
ClientWidth = 4770
BeginProperty Font
name = "MS Sans Serif"
charset = 0
weight = 700
size = 8.25
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
Height = 2505
Left = 1830
LinkTopic = "Form1"
ScaleHeight = 2100
ScaleWidth = 4770
Top = 1710
Width = 4890
Begin VB.CommandButton cmdShowUsers
Caption = "&Show Users"
Enabled = 0 'False
Height = 375
Left = 3240
TabIndex = 6
Top = 600
Width = 1215
End
Begin VB.ComboBox cboGroups
Height = 300
Left = 960
Sorted = -1 'True
Style = 2 'Dropdown List
TabIndex = 4
Top = 600
Width = 2115
End
Begin VB.ComboBox cboUsers
Height = 300
Left = 990
Sorted = -1 'True
Style = 2 'Dropdown List
TabIndex = 2
Top = 120
Width = 2115
End
Begin VB.CommandButton cmdClose
Cancel = -1 'True
Caption = "Cl&ose"
Height = 555
Left = 2520
TabIndex = 1
Top = 1200
Width = 1755
End
Begin VB.CommandButton cmdAddUser
Caption = "&Add User"
Default = -1 'True
Enabled = 0 'False
Height = 555
Left = 480
TabIndex = 0
Top = 1200
Width = 1755
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "&Group"
Height = 195
Left = 180
TabIndex = 5
Top = 660
Width = 525
End
Begin VB.Label Label2
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "&User:"
Height = 195
Left = 240
TabIndex = 3
Top = 180
Width = 465
End
End
Attribute VB_Name = "frmMain"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Private Declare Function GetPrivateProfileString _
Lib "Kernel32" Alias "GetPrivateProfileStringA" (ByVal lpSectionName As String, _
ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal Size As Integer, _
ByVal lpFileName As String) As Integer
Private Sub cboGroups_Click()
cmdAddUser.Enabled = IIf(cboUsers.ListIndex = -1 Or cboGroups.ListIndex = -1, False, True)
cmdShowUsers.Enabled = IIf(cboGroups.ListIndex = -1, False, True)
End Sub
Private Sub cboUsers_Click()
cmdAddUser.Enabled = IIf(cboUsers.ListIndex = -1 Or cboGroups.ListIndex = -1, False, True)
End Sub
Private Sub cmdShowUsers_Click()
frmUsers.Tag = cboGroups.Text
frmUsers.Show 1
End Sub
Private Sub Form_Load()
Dim myUser As String, myPass As String
Dim winDir As String * 128
Dim dirLen As Integer
On Error GoTo LoadError
' Set the user and passwords for initial login.
myUser = "Admin"
myPass = "theboss"
' read VBDBHT.INI to get the name of the system database,
' then assign that name to the SystemDB property
DBEngine.SystemDB = GetSystemDatabase()
' log in
DBEngine.DefaultUser = myUser
DBEngine.DefaultPassword = myPass
FillUserList
FillGroupList
Exit Sub
LoadError:
MsgBox Err & " " & Error$
End
End Sub
Private Sub cmdAddUser_Click()
Dim newGroup As Group
Dim thePID As String
Dim usr As User
On Error GoTo ChangeError
' If the user has not selected both a user and a group, generate an error
If cboUsers.ListIndex = -1 Then Error 32765
If cboGroups.ListIndex = -1 Then Error 32764
' Add the user to the designated group.
Set usr = DBEngine.Workspaces(0).Groups(cboGroups.Text).CreateUser(cboUsers.Text)
DBEngine.Workspaces(0).Groups(cboGroups.Text).Users.Append usr
' No errors, so must have been successful.
MsgBox "User " & cboUsers.Text & " added to " & cboGroups.Text, vbInformation
Exit Sub
ChangeError:
Dim msg As String
Select Case Err.Number
Case 3032
msg = "User " & cboUsers.Text & " already belongs to Group " & cboGroups.Text
Case 32765
msg = "You have not selected a user."
Case 32764
msg = "You have not selected a group."
Case Else
msg = Err.Description
End Select
MsgBox msg, vbExclamation
End Sub
Sub FillUserList()
Dim usr As User
For Each usr In DBEngine.Workspaces(0).Users
If UCase$(usr.Name) <> "CREATOR" And UCase$(usr.Name) <> "ENGINE" Then
cboUsers.AddItem usr.Name
End If
Next
End Sub
Sub FillGroupList()
Dim grp As Group
For Each grp In DBEngine.Workspaces(0).Groups
cboGroups.AddItem grp.Name
Next
End Sub
Private Sub cmdClose_Click()
End
End Sub
Private Function GetSystemDatabase() As String
' Returns the name of the system directory
Const INI_FILENAME = "VBDBHT.INI"
Const MAX_PATH = 128
Dim lpReturnedString As String * MAX_PATH
Dim bytesBack As Integer
bytesBack = GetPrivateProfileString("Options", _
"SystemDB", "", lpReturnedString, MAX_PATH, INI_FILENAME)
GetSystemDatabase = IIf(bytesBack > 0, Left$(lpReturnedString, bytesBack), "")
End Function